home *** CD-ROM | disk | FTP | other *** search
- unit ResFile;
-
- {----------------------------------------------------------------------------------
- Name: ResFile
- Purpose: Implementation of TResFile. This version 16-bit (NE) only.
- Author: Dave Jewell, 1996-1997, ALL RIGHTS RESERVED.
- ----------------------------------------------------------------------------------}
-
- interface
-
- uses WinTypes, WinProcs, Classes, SysUtils;
-
- const
- { Magic numbers }
- DOS_Magic = $5A4D; { Magic word for old-style DOS EXE's }
- W16_Magic = $454E; { Magic word for new-style 16-bit EXE's }
-
- { Error messages - should really go in resources ... }
- eFileNotFound = 'File % not found';
- eFileNotExe = 'File % is not an executable';
- eFileNotNE = 'File % is not a Windows 16-bit (NE) executable';
-
- type
- EResFile = class (Exception);
-
- PResInfo = ^TResInfo;
- TResInfo = record
- ROffset: LongInt; { Offset of resource data }
- RLength: Word; { Length of resource data }
- RFlags: Word; { Flags for this resource }
- end;
-
- TResFile = class (TObject)
- private
- fName: String;
- fMapNames: Boolean;
- fHeaderPos: LongInt;
- fTypesList: TStringList;
- procedure Panic (const Message: String);
- function MapResNumToString (const Name: String): String;
- function MapStringToResNum (const Name: String): String;
- function GetResList (const TypeName: String): TStringList;
- function GetTypeName (Index: Integer): String;
- function GetResourceTypeCount: Integer;
- public
- constructor Create (const FileName: String);
- destructor Destroy;
- property ResTypeCount: Integer read GetResourceTypeCount;
- property ResTypes [Index: Integer]: string read GetTypeName;
- property ResMapNames: Boolean read fMapNames write fMapNames;
- function GetResourceCount (const TypeName: String): Integer;
- function GetResourceName (const TypeName: String; Idx: Integer): String;
- procedure GetResourceInfo (const TypeName: String; Idx: Integer; var Info: TResInfo);
-
- end;
-
- implementation
-
- constructor TResFile.Create (const FileName: String);
- var
- fs: TFileStream;
- ResShift, ResTablePos, ResTableSize: Word;
-
- function ReadByte: Byte;
- begin
- fs.Read (Result, sizeof (Result));
- end;
-
- function ReadWord: Word;
- begin
- fs.Read (Result, sizeof (Result));
- end;
-
- function ReadLong: LongInt;
- begin
- fs.Read (Result, sizeof (Result));
- end;
-
- function ReadString: String;
- var
- Idx, i: Word;
- OldPos: LongInt;
- begin
- Idx := ReadWord; if Idx = 0 then Result := '' else
- if (Idx and $8000) <> 0 then Result := Format ('#%d', [Idx and $7FFF])
- else
- begin
- OldPos := fs.Position;
- fs.Position := fHeaderPos + ResTablePos + Idx {- Ord (fType)};
- Result [0] := Char (ReadByte);
- for i := 1 to Ord (Result [0]) do Result [i] := Char (ReadByte);
- fs.Position := OldPos;
- end;
- end;
-
- function ReadResourceList: Boolean;
- var
- ResType: String;
- i, Count: Integer;
- Res: ^TResInfo;
- List: TStringList;
- begin
- Result := False;
- ResType := ReadString;
- if ResType <> '' then
- begin
- Result := True;
- List := TStringList.Create;
- { Count number of resources of this type }
- Count := ReadWord; ReadLong;
- for i := 0 to Count - 1 do
- begin
- GetMem (Res, sizeof (TResInfo));
- Res^.ROffset := LongInt (ReadWord) shl ResShift;
- Res^.RLength := ReadWord shl ResShift;
- Res^.RFlags := ReadWord;
- List.AddObject (ReadString, TObject (Res));
- ReadLong;
- end;
-
- fTypesList.AddObject (ResType, List);
- end;
- end;
-
- procedure ReadResources;
- var
- ResType: Word;
- begin
- with fs do
- begin
- { Get the size and position of the resource table }
- Position := fHeaderPos + $24; ResTablePos := ReadWord;
- ResTableSize := ReadWord - ResTablePos;
- { Stripping all resources with RW leaves a vestigial 4-byte table }
- if ResTableSize > 4 then
- begin
- Position := fHeaderPos + ResTablePos;
- ResShift := ReadWord;
- while ReadResourceList do ;
- end;
- end;
- end;
-
- begin
- fName := FileName;
- fMapNames := False;
- fTypesList := TStringList.Create;
- if not FileExists (FileName) then Panic (eFileNotFound);
- fs := TFileStream.Create (FileName, fmOpenRead);
- with fs do try
- if ReadWord <> DOS_Magic then Panic (eFileNotExe);
- Position := $3C; Position := ReadLong; fHeaderPos := Position;
- if ReadWord <> W16_Magic then Panic (eFileNotNE);
- { OK - We know it's a NE executable - now load what we're after }
- ReadResources;
- finally
- fs.Free;
- end;
- end;
-
- destructor TResFile.Destroy;
- var
- j: Integer;
- TypeList: TStringList;
- begin
- while fTypesList.Count > 0 do
- begin
- TypeList := TStringList (fTypesList.Objects [0]);
- for j := 0 to TypeList.Count - 1 do
- FreeMem (TypeList.Objects [j], sizeof (TResInfo));
- TypeList.Free;
- fTypesList.Delete (0);
- end;
-
- fTypesList.Free;
- end;
-
- procedure TResFile.Panic (const Message: String);
- var
- p: Integer;
- Str: String;
- begin
- p := Pos ('%', Message);
- if p = 0 then Str := Message
- else Str := Copy (Message, 1, p - 1) + '"' + fName + '"' + Copy (Message, p + 1, 255);
- raise EResFile.Create (Str);
- end;
-
- function TResFile.GetResourceTypeCount: Integer;
- begin
- Result := fTypesList.Count;
- end;
-
- function TResFile.MapResNumToString (const Name: String): String;
- begin
- Result := Name;
- if (Result [1] = '#') and fMapNames then
- case StrToInt (Copy (Result, 2, 255)) of
- 1: Result := 'CURSOR';
- 2: Result := 'BITMAP';
- 3: Result := 'ICON';
- 4: Result := 'MENU';
- 5: Result := 'DIALOG';
- 6: Result := 'STRINGTABLE';
- 7: Result := 'FONTDIR';
- 8: Result := 'FONT';
- 9: Result := 'ACCELERATOR';
- 10: Result := 'RCDATA';
- 12: Result := 'GROUPCURSOR';
- 14: Result := 'GROUPICON';
- 16: Result := 'VERSIONINFO';
- end;
- end;
-
- function TResFile.MapStringToResNum (const Name: String): String;
- var
- Num: Integer;
- begin
- Num := -1;
- if (Name [1] <> '#') and fMapNames then
- begin
- if Name = 'CURSOR' then Num := 1;
- if Name = 'BITMAP' then Num := 2;
- if Name = 'ICON' then Num := 3;
- if Name = 'MENU' then Num := 4;
- if Name = 'DIALOG' then Num := 5;
- if Name = 'STRINGTABLE' then Num := 6;
- if Name = 'FONTDIR' then Num := 7;
- if Name = 'FONT' then Num := 8;
- if Name = 'ACCELERATOR' then Num := 9;
- if Name = 'RCDATA' then Num := 10;
- if Name = 'GROUPCURSOR' then Num := 12;
- if Name = 'GROUPICON' then Num := 14;
- if Name = 'VERSIONINFO' then Num := 16;
- end;
-
- if Num = -1 then Result := Name else Result := '#' + IntToStr (Num);
- end;
-
- function TResFile.GetTypeName (Index: Integer): String;
- begin
- Result := '';
- if (Index >= 0) and (Index < fTypesList.Count) then
- Result := MapResNumToString (fTypesList.Strings [Index]);
- end;
-
- function TResFile.GetResList (const TypeName: String): TStringList;
- var
- Idx: Integer;
- begin
- Idx := fTypesList.IndexOf (MapStringToResNum (TypeName));
- if Idx = -1 then Result := Nil
- else Result := fTypesList.Objects [Idx] as TStringList;
- end;
-
- function TResFile.GetResourceCount (const TypeName: String): Integer;
- var
- List: TStringList;
- begin
- List := GetResList (TypeName);
- if List = Nil then Result := 0 else Result := List.Count;
- end;
-
- function TResFile.GetResourceName (const TypeName: String; Idx: Integer): String;
- var
- List: TStringList;
- begin
- Result := '';
- List := GetResList (TypeName);
- if (List <> Nil) and (Idx >= 0) and (Idx < List.Count) then
- Result := List.Strings [Idx]
- end;
-
- procedure TResFile.GetResourceInfo (const TypeName: String; Idx: Integer; var Info: TResInfo);
- var
- pInfo: PResInfo;
- List: TStringList;
- begin
- List := GetResList (TypeName);
- if (List <> Nil) and (Idx >= 0) and (Idx < List.Count) then
- Info := PResInfo (List.Objects [Idx])^;
- end;
-
- end.
-